#lang scheme/gui

(provide DEBUG
         TEMP_FILE_NAME
         toggle-debug
         printd
         cons-last!
         hash-ref!
         get-input
         create-menu
         create-menu-item
         length<
         overlap
         shortest-list)


(require
 (lib "1.ss" "srfi")
 (lib "defmacro.ss"))


;;redefine printf with a debug wrapper
(define DEBUG #t)
(define TEMP_FILE_NAME "__SchemeGraphGUI_tmp__.dot")
(define (toggle-debug) (set! DEBUG (not DEBUG)))

(define-macro (printd args . rest)
  `(if DEBUG ,(cons 'printf (cons args rest)) '()))


;;cons's an element to the end of a list instead of the beginning
(define-macro (cons-last! e l)
  `(set! ,l (append ,l (list ,e))))


;;same as hash-ref, but on failure, the failure result gets added to the hash
(define-macro (hash-ref! ht key value)
  `(force (hash-ref ,ht ,key
                    (delay
                      (let ((val ,value))
                        (hash-set! ,ht ,key val)
                        val)))))


;;gets an input from a user by displaying a dialog box with a prompt
(define (get-input prompt)
  (let* ((dialog (new dialog% (label "")))
         (txtbox (new text-field%
                      [parent dialog]
                      [label prompt]
                      [callback (lambda (i e)
                                  (when (eq? (send e get-event-type)
                                             'text-field-enter)
                                        (send dialog show #f)))])))
    (send txtbox focus)
    (send dialog show #t)
    (send txtbox get-value)))


;;Helper function for creating menus
(define (create-menu n p)
  (let* ((szn (symbol->string n))
         (name (string->symbol (string-append szn "-menu")))
         (l (regexp-replace #rx"." szn string-upcase)))
    (eval `(define ,name (new menu% (label ,l) (parent ,p))))))


;;Helper function for creating menu-items
(define (create-menu-item n p)
  (let* ((szn (symbol->string n))
         (szp (symbol->string p))
         (name (string->symbol (string-append szp "-" szn)))
         (l (regexp-replace #rx"." (regexp-replace #rx"-" szn " ") string-upcase))
         (c (string->symbol (string-append szp "-" szn "-callback"))))
    (eval `(define ,name (new menu-item% (label ,l) (parent ,p) (callback ,c))))))


;same as, but more efficient than (< (length l) n)
(define (length< l n)
  (cond ((= 0 n) #f)
        ((null? l) #t)
        (#t (length< (cdr l) (- n 1)))))


;returns the shortest list in a list of lists
(define (shortest-list l)
  (car (fold (lambda(l1 r) (if (length< l1 (cdr r)) (cons l1 (length l1)) r))
             (cons '() +inf.0)
             l)))


;returns the amount of overlap between the tail of l1 and the head of l2
(define (overlap l1 l2)
  (do ((i (min (length l1) (length l2)) (- i 1)))
      ((equal? (take-right l1 i) (take l2 i)) i)))
